home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Tcl / tclEvent.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-07-21  |  63.1 KB  |  2,283 lines
  1. /* 
  2.  * tclEvent.c --
  3.  *
  4.  *    This file provides basic event-managing facilities for Tcl,
  5.  *    including an event queue, and mechanisms for attaching
  6.  *    callbacks to certain events.
  7.  *
  8.  *    It also contains the command procedures for the commands
  9.  *    "after", "vwait", and "update".
  10.  *
  11.  * Copyright (c) 1990-1994 The Regents of the University of California.
  12.  * Copyright (c) 1994-1995 Sun Microsystems, Inc.
  13.  *
  14.  * See the file "license.terms" for information on usage and redistribution
  15.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  16.  *
  17.  * SCCS: @(#) tclEvent.c 1.127 96/03/22 12:12:33
  18.  */
  19.  
  20. #include "tclInt.h"
  21. #include "tclPort.h"
  22.  
  23. /*
  24.  * For each file registered in a call to Tcl_CreateFileHandler,
  25.  * there is one record of the following type.  All of these records
  26.  * are chained together into a single list.
  27.  */
  28.  
  29. typedef struct FileHandler {
  30.     Tcl_File file;        /* Generic file handle for file. */
  31.     int mask;            /* Mask of desired events: TCL_READABLE, etc. */
  32.     int readyMask;        /* Events that were ready the last time that
  33.                  * FileHandlerCheckProc checked this file. */
  34.     Tcl_FileProc *proc;        /* Procedure to call, in the style of
  35.                  * Tcl_CreateFileHandler.  This is NULL
  36.                  * if the handler was created by
  37.                  * Tcl_CreateFileHandler2. */
  38.     ClientData clientData;    /* Argument to pass to proc. */
  39.     struct FileHandler *nextPtr;/* Next in list of all files we care
  40.                  * about (NULL for end of list). */
  41. } FileHandler;
  42.  
  43. static FileHandler *firstFileHandlerPtr = (FileHandler *) NULL;
  44.                 /* List of all file handlers. */
  45. static int fileEventSourceCreated = 0;
  46.                 /* Non-zero means that the file event source
  47.                  * hasn't been registerd with the Tcl
  48.                  * notifier yet. */
  49.  
  50. /*
  51.  * The following structure is what is added to the Tcl event queue when
  52.  * file handlers are ready to fire.
  53.  */
  54.  
  55. typedef struct FileHandlerEvent {
  56.     Tcl_Event header;        /* Information that is standard for
  57.                  * all events. */
  58.     Tcl_File file;        /* File descriptor that is ready.  Used
  59.                  * to find the FileHandler structure for
  60.                  * the file (can't point directly to the
  61.                  * FileHandler structure because it could
  62.                  * go away while the event is queued). */
  63. } FileHandlerEvent;
  64.  
  65. /*
  66.  * For each timer callback that's pending (either regular or "modal"),
  67.  * there is one record of the following type.  The normal handlers
  68.  * (created by Tcl_CreateTimerHandler) are chained together in a
  69.  * list sorted by time (earliest event first).
  70.  */
  71.  
  72. typedef struct TimerHandler {
  73.     Tcl_Time time;            /* When timer is to fire. */
  74.     Tcl_TimerProc *proc;        /* Procedure to call. */
  75.     ClientData clientData;        /* Argument to pass to proc. */
  76.     Tcl_TimerToken token;        /* Identifies event so it can be
  77.                      * deleted.  Not used in modal
  78.                      * timeouts. */
  79.     struct TimerHandler *nextPtr;    /* Next event in queue, or NULL for
  80.                      * end of queue. */
  81. } TimerHandler;
  82.  
  83. static TimerHandler *firstTimerHandlerPtr = NULL;
  84.                     /* First event in queue. */
  85. static int timerEventSourceCreated = 0;    /* 0 means that the timer event source
  86.                      * hasn't yet been registered with the
  87.                      * Tcl notifier. */
  88.  
  89. /*
  90.  * The information below describes a stack of modal timeouts managed by
  91.  * Tcl_CreateModalTimer and Tcl_DeleteModalTimer.  Only the first element
  92.  * in the list is used at any given time.
  93.  */
  94.  
  95. static TimerHandler *firstModalHandlerPtr = NULL;
  96.  
  97. /*
  98.  * The following structure is what's added to the Tcl event queue when
  99.  * timer handlers are ready to fire.
  100.  */
  101.  
  102. typedef struct TimerEvent {
  103.     Tcl_Event header;            /* Information that is standard for
  104.                      * all events. */
  105.     Tcl_Time time;            /* All timer events that specify this
  106.                      * time or earlier are ready
  107.                                          * to fire. */
  108. } TimerEvent;
  109.  
  110. /*
  111.  * There is one of the following structures for each of the
  112.  * handlers declared in a call to Tcl_DoWhenIdle.  All of the
  113.  * currently-active handlers are linked together into a list.
  114.  */
  115.  
  116. typedef struct IdleHandler {
  117.     Tcl_IdleProc (*proc);    /* Procedure to call. */
  118.     ClientData clientData;    /* Value to pass to proc. */
  119.     int generation;        /* Used to distinguish older handlers from
  120.                  * recently-created ones. */
  121.     struct IdleHandler *nextPtr;/* Next in list of active handlers. */
  122. } IdleHandler;
  123.  
  124. static IdleHandler *idleList = NULL;
  125.                 /* First in list of all idle handlers. */
  126. static IdleHandler *lastIdlePtr = NULL;
  127.                 /* Last in list (or NULL for empty list). */
  128. static int idleGeneration = 0;    /* Used to fill in the "generation" fields
  129.                  * of IdleHandler structures.  Increments
  130.                  * each time Tcl_DoOneEvent starts calling
  131.                  * idle handlers, so that all old handlers
  132.                  * can be called without calling any of the
  133.                  * new ones created by old ones. */
  134.  
  135. /*
  136.  * The data structure below is used by the "after" command to remember
  137.  * the command to be executed later.  All of the pending "after" commands
  138.  * for an interpreter are linked together in a list.
  139.  */
  140.  
  141. typedef struct AfterInfo {
  142.     struct AfterAssocData *assocPtr;
  143.                 /* Pointer to the "tclAfter" assocData for
  144.                  * the interp in which command will be
  145.                  * executed. */
  146.     char *command;        /* Command to execute.  Malloc'ed, so must
  147.                  * be freed when structure is deallocated. */
  148.     int id;            /* Integer identifier for command;  used to
  149.                  * cancel it. */
  150.     Tcl_TimerToken token;    /* Used to cancel the "after" command.  NULL
  151.                  * means that the command is run as an
  152.                  * idle handler rather than as a timer
  153.                  * handler.  NULL means this is an "after
  154.                  * idle" handler rather than a
  155.                                  * timer handler. */
  156.     struct AfterInfo *nextPtr;    /* Next in list of all "after" commands for
  157.                  * this interpreter. */
  158. } AfterInfo;
  159.  
  160. /*
  161.  * One of the following structures is associated with each interpreter
  162.  * for which an "after" command has ever been invoked.  A pointer to
  163.  * this structure is stored in the AssocData for the "tclAfter" key.
  164.  */
  165.  
  166. typedef struct AfterAssocData {
  167.     Tcl_Interp *interp;        /* The interpreter for which this data is
  168.                  * registered. */
  169.     AfterInfo *firstAfterPtr;    /* First in list of all "after" commands
  170.                  * still pending for this interpreter, or
  171.                  * NULL if none. */
  172. } AfterAssocData;
  173.  
  174. #ifdef STk_CODE
  175. static AfterAssocData After_list;
  176. #endif
  177.  
  178.  
  179.  
  180. /*
  181.  * The data structure below is used to report background errors.  One
  182.  * such structure is allocated for each error;  it holds information
  183.  * about the interpreter and the error until bgerror can be invoked
  184.  * later as an idle handler.
  185.  */
  186.  
  187. typedef struct BgError {
  188.     Tcl_Interp *interp;        /* Interpreter in which error occurred.  NULL
  189.                  * means this error report has been cancelled
  190.                  * (a previous report generated a break). */
  191.     char *errorMsg;        /* The error message (interp->result when
  192.                  * the error occurred).  Malloc-ed. */
  193.     char *errorInfo;        /* Value of the errorInfo variable
  194.                  * (malloc-ed). */
  195.     char *errorCode;        /* Value of the errorCode variable
  196.                  * (malloc-ed). */
  197.     struct BgError *nextPtr;    /* Next in list of all pending error
  198.                  * reports for this interpreter, or NULL
  199.                  * for end of list. */
  200. } BgError;
  201.  
  202. /*
  203.  * One of the structures below is associated with the "tclBgError"
  204.  * assoc data for each interpreter.  It keeps track of the head and
  205.  * tail of the list of pending background errors for the interpreter.
  206.  */
  207.  
  208. typedef struct ErrAssocData {
  209.     BgError *firstBgPtr;    /* First in list of all background errors
  210.                  * waiting to be processed for this
  211.                  * interpreter (NULL if none). */
  212.     BgError *lastBgPtr;        /* Last in list of all background errors
  213.                  * waiting to be processed for this
  214.                  * interpreter (NULL if none). */
  215. } ErrAssocData;
  216.  
  217. /*
  218.  * For each exit handler created with a call to Tcl_CreateExitHandler
  219.  * there is a structure of the following type:
  220.  */
  221.  
  222. typedef struct ExitHandler {
  223.     Tcl_ExitProc *proc;        /* Procedure to call when process exits. */
  224.     ClientData clientData;    /* One word of information to pass to proc. */
  225.     struct ExitHandler *nextPtr;/* Next in list of all exit handlers for
  226.                  * this application, or NULL for end of list. */
  227. } ExitHandler;
  228.  
  229. static ExitHandler *firstExitPtr = NULL;
  230.                 /* First in list of all exit handlers for
  231.                  * application. */
  232.  
  233. /*
  234.  * Structures of the following type are used during the execution
  235.  * of Tcl_WaitForFile, to keep track of the file and timeout.
  236.  */
  237.  
  238. typedef struct FileWait {
  239.     Tcl_File file;        /* File to wait on. */
  240.     int mask;            /* Conditions to wait for (TCL_READABLE,
  241.                  * etc.) */
  242.     int timeout;        /* Original "timeout" argument to
  243.                  * Tcl_WaitForFile. */
  244.     Tcl_Time abortTime;        /* Time at which to abort the wait. */
  245.     int present;        /* Conditions present on the file during
  246.                  * the last time through the event loop. */
  247.     int done;            /* Non-zero means we're done:  either one of
  248.                  * the desired conditions is present or the
  249.                  * timeout period has elapsed. */
  250. } FileWait;
  251.  
  252. /*
  253.  * The following variable is a "secret" indication to Tcl_Exit that
  254.  * it should dump out the state of memory before exiting.  If the
  255.  * value is non-NULL, it gives the name of the file in which to
  256.  * dump memory usage information.
  257.  */
  258.  
  259. char *tclMemDumpFileName = NULL;
  260.  
  261. /*
  262.  * Prototypes for procedures referenced only in this file:
  263.  */
  264.  
  265. static void        AfterCleanupProc _ANSI_ARGS_((ClientData clientData,
  266.                 Tcl_Interp *interp));
  267. static void        AfterProc _ANSI_ARGS_((ClientData clientData));
  268. static void        BgErrorDeleteProc _ANSI_ARGS_((ClientData clientData,
  269.                 Tcl_Interp *interp));
  270. static void        FileHandlerCheckProc _ANSI_ARGS_((
  271.                 ClientData clientData, int flags));
  272. static int        FileHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
  273.                 int flags));
  274. static void        FileHandlerExitProc _ANSI_ARGS_((ClientData data));
  275. static void        FileHandlerSetupProc _ANSI_ARGS_((
  276.                 ClientData clientData, int flags));
  277. static void        FreeAfterPtr _ANSI_ARGS_((AfterInfo *afterPtr));
  278. static AfterInfo *    GetAfterEvent _ANSI_ARGS_((AfterAssocData *assocPtr,
  279.                 char *string));
  280. static void        HandleBgErrors _ANSI_ARGS_((ClientData clientData));
  281. static void        TimerHandlerCheckProc _ANSI_ARGS_((
  282.                 ClientData clientData, int flags));
  283. static int        TimerHandlerEventProc _ANSI_ARGS_((Tcl_Event *evPtr,
  284.                 int flags));
  285. static void        TimerHandlerExitProc _ANSI_ARGS_((ClientData data));
  286. static void        TimerHandlerSetupProc _ANSI_ARGS_((
  287.                 ClientData clientData, int flags));
  288. static char *        VwaitVarProc _ANSI_ARGS_((ClientData clientData,
  289.                 Tcl_Interp *interp, char *name1, char *name2,
  290.                 int flags));
  291.  
  292. /*
  293.  *--------------------------------------------------------------
  294.  *
  295.  * Tcl_CreateFileHandler --
  296.  *
  297.  *    Arrange for a given procedure to be invoked whenever
  298.  *    a given file becomes readable or writable.
  299.  *
  300.  * Results:
  301.  *    None.
  302.  *
  303.  * Side effects:
  304.  *    From now on, whenever the I/O channel given by file becomes
  305.  *    ready in the way indicated by mask, proc will be invoked.
  306.  *    See the manual entry for details on the calling sequence
  307.  *    to proc.  If file is already registered then the old mask
  308.  *    and proc and clientData values will be replaced with
  309.  *    new ones.
  310.  *
  311.  *--------------------------------------------------------------
  312.  */
  313.  
  314. void
  315. Tcl_CreateFileHandler(file, mask, proc, clientData)
  316.     Tcl_File file;        /* Handle of stream to watch. */
  317.     int mask;            /* OR'ed combination of TCL_READABLE,
  318.                  * TCL_WRITABLE, and TCL_EXCEPTION:
  319.                  * indicates conditions under which
  320.                  * proc should be called. */
  321.     Tcl_FileProc *proc;        /* Procedure to call for each
  322.                  * selected event. */
  323.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  324. {
  325.     register FileHandler *filePtr;
  326.  
  327.     if (!fileEventSourceCreated) {
  328.     fileEventSourceCreated = 1;
  329.     Tcl_CreateEventSource(FileHandlerSetupProc, FileHandlerCheckProc,
  330.         (ClientData) NULL);
  331.         Tcl_CreateExitHandler(FileHandlerExitProc, (ClientData) NULL);
  332.     }
  333.  
  334.     /*
  335.      * Make sure the file isn't already registered.  Create a
  336.      * new record in the normal case where there's no existing
  337.      * record.
  338.      */
  339.  
  340.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  341.         filePtr = filePtr->nextPtr) {
  342.     if (filePtr->file == file) {
  343.         break;
  344.     }
  345.     }
  346.     if (filePtr == NULL) {
  347.     filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
  348.     filePtr->file = file;
  349.     filePtr->nextPtr = firstFileHandlerPtr;
  350.     firstFileHandlerPtr = filePtr;
  351.     }
  352.  
  353.     /*
  354.      * The remainder of the initialization below is done regardless
  355.      * of whether or not this is a new record or a modification of
  356.      * an old one.
  357.      */
  358.  
  359.     filePtr->mask = mask;
  360.     filePtr->readyMask = 0;
  361.     filePtr->proc = proc;
  362.     filePtr->clientData = clientData;
  363. }
  364.  
  365. /*
  366.  *--------------------------------------------------------------
  367.  *
  368.  * Tcl_DeleteFileHandler --
  369.  *
  370.  *    Cancel a previously-arranged callback arrangement for
  371.  *    a file.
  372.  *
  373.  * Results:
  374.  *    None.
  375.  *
  376.  * Side effects:
  377.  *    If a callback was previously registered on file, remove it.
  378.  *
  379.  *--------------------------------------------------------------
  380.  */
  381.  
  382. void
  383. Tcl_DeleteFileHandler(file)
  384.     Tcl_File file;        /* Stream id for which to remove
  385.                  * callback procedure. */
  386. {
  387.     FileHandler *filePtr, *prevPtr;
  388.  
  389.     /*
  390.      * Find the entry for the given file (and return if there
  391.      * isn't one).
  392.      */
  393.  
  394.     for (prevPtr = NULL, filePtr = firstFileHandlerPtr; ;
  395.         prevPtr = filePtr, filePtr = filePtr->nextPtr) {
  396.     if (filePtr == NULL) {
  397.         return;
  398.     }
  399.     if (filePtr->file == file) {
  400.         break;
  401.     }
  402.     }
  403.  
  404.     /*
  405.      * Clean up information in the callback record.
  406.      */
  407.  
  408.     if (prevPtr == NULL) {
  409.     firstFileHandlerPtr = filePtr->nextPtr;
  410.     } else {
  411.     prevPtr->nextPtr = filePtr->nextPtr;
  412.     }
  413.     ckfree((char *) filePtr);
  414. }
  415.  
  416. /*
  417.  *----------------------------------------------------------------------
  418.  *
  419.  * FileHandlerExitProc --
  420.  *
  421.  *    Cleanup procedure to delete the file event source during exit
  422.  *    cleanup.
  423.  *
  424.  * Results:
  425.  *    None.
  426.  *
  427.  * Side effects:
  428.  *    Destroys the file event source.
  429.  *
  430.  *----------------------------------------------------------------------
  431.  */
  432.  
  433.     /* ARGSUSED */
  434. static void
  435. FileHandlerExitProc(clientData)
  436.     ClientData clientData;        /* Not used. */
  437. {
  438.     Tcl_DeleteEventSource(FileHandlerSetupProc, FileHandlerCheckProc,
  439.             (ClientData) NULL);
  440. }
  441.  
  442. /*
  443.  *----------------------------------------------------------------------
  444.  *
  445.  * FileHandlerSetupProc --
  446.  *
  447.  *    This procedure is part of the "event source" for file handlers.
  448.  *    It is invoked by Tcl_DoOneEvent before it calls select (or
  449.  *    whatever it uses to wait).
  450.  *
  451.  * Results:
  452.  *    None.
  453.  *
  454.  * Side effects:
  455.  *    Tells the notifier which files should be waited for.
  456.  *
  457.  *----------------------------------------------------------------------
  458.  */
  459.  
  460. static void
  461. FileHandlerSetupProc(clientData, flags)
  462.     ClientData clientData;        /* Not used. */
  463.     int flags;                /* Flags passed to Tk_DoOneEvent:
  464.                      * if it doesn't include
  465.                      * TCL_FILE_EVENTS then we do
  466.                      * nothing. */
  467. {
  468.     FileHandler *filePtr;
  469.  
  470.     if (!(flags & TCL_FILE_EVENTS)) {
  471.     return;
  472.     }
  473.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  474.         filePtr = filePtr->nextPtr) {
  475.     if (filePtr->mask != 0) {
  476.         Tcl_WatchFile(filePtr->file, filePtr->mask);
  477.     }
  478.     }
  479. }
  480.  
  481. /*
  482.  *----------------------------------------------------------------------
  483.  *
  484.  * FileHandlerCheckProc --
  485.  *
  486.  *    This procedure is the second part of the "event source" for
  487.  *    file handlers.  It is invoked by Tcl_DoOneEvent after it calls
  488.  *    select (or whatever it uses to wait for events).
  489.  *
  490.  * Results:
  491.  *    None.
  492.  *
  493.  * Side effects:
  494.  *    Makes entries on the Tcl event queue for each file that is
  495.  *    now ready.
  496.  *
  497.  *----------------------------------------------------------------------
  498.  */
  499.  
  500. static void
  501. FileHandlerCheckProc(clientData, flags)
  502.     ClientData clientData;        /* Not used. */
  503.     int flags;                /* Flags passed to Tk_DoOneEvent:
  504.                      * if it doesn't include 
  505.                      * TCL_FILE_EVENTS then we do
  506.                      * nothing. */
  507. {
  508.     FileHandler *filePtr;
  509.     FileHandlerEvent *fileEvPtr;
  510.  
  511.     if (!(flags & TCL_FILE_EVENTS)) {
  512.     return;
  513.     }
  514.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  515.         filePtr = filePtr->nextPtr) {
  516.     if (filePtr->mask != 0) {
  517.         filePtr->readyMask = Tcl_FileReady(filePtr->file, filePtr->mask);
  518.         if (filePtr->readyMask != 0) {
  519.         fileEvPtr = (FileHandlerEvent *) ckalloc(
  520.             sizeof(FileHandlerEvent));
  521.         fileEvPtr->header.proc = FileHandlerEventProc;
  522.         fileEvPtr->file = filePtr->file;
  523.         Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
  524.         }
  525.     }
  526.     }
  527. }
  528.  
  529. /*
  530.  *----------------------------------------------------------------------
  531.  *
  532.  * FileHandlerEventProc --
  533.  *
  534.  *    This procedure is called by Tcl_DoOneEvent when a file event
  535.  *    reaches the front of the event queue.  This procedure is responsible
  536.  *    for actually handling the event by invoking the callback for the
  537.  *    file handler.
  538.  *
  539.  * Results:
  540.  *    Returns 1 if the event was handled, meaning it should be removed
  541.  *    from the queue.  Returns 0 if the event was not handled, meaning
  542.  *    it should stay on the queue.  The only time the event isn't
  543.  *    handled is if the TCL_FILE_EVENTS flag bit isn't set.
  544.  *
  545.  * Side effects:
  546.  *    Whatever the file handler's callback procedure does
  547.  *
  548.  *----------------------------------------------------------------------
  549.  */
  550.  
  551. static int
  552. FileHandlerEventProc(evPtr, flags)
  553.     Tcl_Event *evPtr;        /* Event to service. */
  554.     int flags;            /* Flags that indicate what events to
  555.                  * handle, such as TCL_FILE_EVENTS. */
  556. {
  557.     FileHandler *filePtr;
  558.     FileHandlerEvent *fileEvPtr = (FileHandlerEvent *) evPtr;
  559.     int mask;
  560.  
  561.     if (!(flags & TCL_FILE_EVENTS)) {
  562.     return 0;
  563.     }
  564.  
  565.     /*
  566.      * Search through the file handlers to find the one whose handle matches
  567.      * the event.  We do this rather than keeping a pointer to the file
  568.      * handler directly in the event, so that the handler can be deleted
  569.      * while the event is queued without leaving a dangling pointer.
  570.      */
  571.  
  572.     for (filePtr = firstFileHandlerPtr; filePtr != NULL;
  573.         filePtr = filePtr->nextPtr) {
  574.     if (filePtr->file != fileEvPtr->file) {
  575.         continue;
  576.     }
  577.  
  578.     /*
  579.      * The code is tricky for two reasons:
  580.      * 1. The file handler's desired events could have changed
  581.      *    since the time when the event was queued, so AND the
  582.      *    ready mask with the desired mask.
  583.      * 2. The file could have been closed and re-opened since
  584.      *    the time when the event was queued.  This is why the
  585.      *    ready mask is stored in the file handler rather than
  586.      *    the queued event:  it will be zeroed when a new
  587.      *    file handler is created for the newly opened file.
  588.      */
  589.  
  590.     mask = filePtr->readyMask & filePtr->mask;
  591.     filePtr->readyMask = 0;
  592.     if (mask != 0) {
  593.         (*filePtr->proc)(filePtr->clientData, mask);
  594.     }
  595.     break;
  596.     }
  597.     return 1;
  598. }
  599.  
  600. /*
  601.  *--------------------------------------------------------------
  602.  *
  603.  * Tcl_CreateTimerHandler --
  604.  *
  605.  *    Arrange for a given procedure to be invoked at a particular
  606.  *    time in the future.
  607.  *
  608.  * Results:
  609.  *    The return value is a token for the timer event, which
  610.  *    may be used to delete the event before it fires.
  611.  *
  612.  * Side effects:
  613.  *    When milliseconds have elapsed, proc will be invoked
  614.  *    exactly once.
  615.  *
  616.  *--------------------------------------------------------------
  617.  */
  618.  
  619. Tcl_TimerToken
  620. Tcl_CreateTimerHandler(milliseconds, proc, clientData)
  621.     int milliseconds;        /* How many milliseconds to wait
  622.                  * before invoking proc. */
  623.     Tcl_TimerProc *proc;    /* Procedure to invoke. */
  624.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  625. {
  626.     register TimerHandler *timerHandlerPtr, *tPtr2, *prevPtr;
  627.     static int id = 0;
  628.  
  629.     if (!timerEventSourceCreated) {
  630.     timerEventSourceCreated = 1;
  631.     Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
  632.         (ClientData) NULL);
  633.         Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL);
  634.     }
  635.  
  636.     timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
  637.  
  638.     /*
  639.      * Compute when the event should fire.
  640.      */
  641.  
  642.     TclGetTime(&timerHandlerPtr->time);
  643.     timerHandlerPtr->time.sec += milliseconds/1000;
  644.     timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
  645.     if (timerHandlerPtr->time.usec >= 1000000) {
  646.     timerHandlerPtr->time.usec -= 1000000;
  647.     timerHandlerPtr->time.sec += 1;
  648.     }
  649.     
  650.     /*
  651.      * Fill in other fields for the event.
  652.      */
  653.  
  654.     timerHandlerPtr->proc = proc;
  655.     timerHandlerPtr->clientData = clientData;
  656.     id++;
  657.     timerHandlerPtr->token = (Tcl_TimerToken) id;
  658.  
  659.     /*
  660.      * Add the event to the queue in the correct position
  661.      * (ordered by event firing time).
  662.      */
  663.  
  664.     for (tPtr2 = firstTimerHandlerPtr, prevPtr = NULL; tPtr2 != NULL;
  665.         prevPtr = tPtr2, tPtr2 = tPtr2->nextPtr) {
  666.     if ((tPtr2->time.sec > timerHandlerPtr->time.sec)
  667.         || ((tPtr2->time.sec == timerHandlerPtr->time.sec)
  668.         && (tPtr2->time.usec > timerHandlerPtr->time.usec))) {
  669.         break;
  670.     }
  671.     }
  672.     timerHandlerPtr->nextPtr = tPtr2;
  673.     if (prevPtr == NULL) {
  674.     firstTimerHandlerPtr = timerHandlerPtr;
  675.     } else {
  676.     prevPtr->nextPtr = timerHandlerPtr;
  677.     }
  678.     return timerHandlerPtr->token;
  679. }
  680.  
  681. /*
  682.  *--------------------------------------------------------------
  683.  *
  684.  * Tcl_DeleteTimerHandler --
  685.  *
  686.  *    Delete a previously-registered timer handler.
  687.  *
  688.  * Results:
  689.  *    None.
  690.  *
  691.  * Side effects:
  692.  *    Destroy the timer callback identified by TimerToken,
  693.  *    so that its associated procedure will not be called.
  694.  *    If the callback has already fired, or if the given
  695.  *    token doesn't exist, then nothing happens.
  696.  *
  697.  *--------------------------------------------------------------
  698.  */
  699.  
  700. void
  701. Tcl_DeleteTimerHandler(token)
  702.     Tcl_TimerToken token;    /* Result previously returned by
  703.                  * Tcl_DeleteTimerHandler. */
  704. {
  705.     register TimerHandler *timerHandlerPtr, *prevPtr;
  706.  
  707.     for (timerHandlerPtr = firstTimerHandlerPtr, prevPtr = NULL;
  708.         timerHandlerPtr != NULL; prevPtr = timerHandlerPtr,
  709.         timerHandlerPtr = timerHandlerPtr->nextPtr) {
  710.     if (timerHandlerPtr->token != token) {
  711.         continue;
  712.     }
  713.     if (prevPtr == NULL) {
  714.         firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
  715.     } else {
  716.         prevPtr->nextPtr = timerHandlerPtr->nextPtr;
  717.     }
  718.     ckfree((char *) timerHandlerPtr);
  719.     return;
  720.     }
  721. }
  722.  
  723. /*
  724.  *--------------------------------------------------------------
  725.  *
  726.  * Tcl_CreateModalTimeout --
  727.  *
  728.  *    Arrange for a given procedure to be invoked at a particular
  729.  *    time in the future, independently of all other timer events.
  730.  *
  731.  * Results:
  732.  *    None.
  733.  *
  734.  * Side effects:
  735.  *    When milliseconds have elapsed, proc will be invoked
  736.  *    exactly once.
  737.  *
  738.  *--------------------------------------------------------------
  739.  */
  740.  
  741. void
  742. Tcl_CreateModalTimeout(milliseconds, proc, clientData)
  743.     int milliseconds;        /* How many milliseconds to wait
  744.                  * before invoking proc. */
  745.     Tcl_TimerProc *proc;    /* Procedure to invoke. */
  746.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  747. {
  748.     TimerHandler *timerHandlerPtr;
  749.  
  750.     if (!timerEventSourceCreated) {
  751.     timerEventSourceCreated = 1;
  752.     Tcl_CreateEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
  753.         (ClientData) NULL);
  754.         Tcl_CreateExitHandler(TimerHandlerExitProc, (ClientData) NULL);
  755.     }
  756.  
  757.     timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
  758.  
  759.     /*
  760.      * Compute when the timeout should fire and fill in the other fields
  761.      * of the handler.
  762.      */
  763.  
  764.     TclGetTime(&timerHandlerPtr->time);
  765.     timerHandlerPtr->time.sec += milliseconds/1000;
  766.     timerHandlerPtr->time.usec += (milliseconds%1000)*1000;
  767.     if (timerHandlerPtr->time.usec >= 1000000) {
  768.     timerHandlerPtr->time.usec -= 1000000;
  769.     timerHandlerPtr->time.sec += 1;
  770.     }
  771.     timerHandlerPtr->proc = proc;
  772.     timerHandlerPtr->clientData = clientData;
  773.  
  774.     /*
  775.      * Push the handler on the top of the modal stack.
  776.      */
  777.  
  778.     timerHandlerPtr->nextPtr = firstModalHandlerPtr;
  779.     firstModalHandlerPtr = timerHandlerPtr;
  780. }
  781.  
  782. /*
  783.  *--------------------------------------------------------------
  784.  *
  785.  * Tcl_DeleteModalTimeout --
  786.  *
  787.  *    Remove the topmost modal timer handler from the stack of
  788.  *    modal  handlers.
  789.  *
  790.  * Results:
  791.  *    None.
  792.  *
  793.  * Side effects:
  794.  *    Destroys the topmost modal timeout handler, which must
  795.  *    match proc and clientData.
  796.  *
  797.  *--------------------------------------------------------------
  798.  */
  799.  
  800. void
  801. Tcl_DeleteModalTimeout(proc, clientData)
  802.     Tcl_TimerProc *proc;    /* Callback procedure for the timeout. */
  803.     ClientData clientData;    /* Arbitrary data to pass to proc. */
  804. {
  805.     TimerHandler *timerHandlerPtr;
  806.  
  807.     timerHandlerPtr = firstModalHandlerPtr;
  808.     firstModalHandlerPtr = timerHandlerPtr->nextPtr;
  809.     if ((timerHandlerPtr->proc != proc)
  810.         || (timerHandlerPtr->clientData != clientData)) {
  811.     panic("Tcl_DeleteModalTimeout found timeout stack corrupted");
  812.     }
  813.     ckfree((char *) timerHandlerPtr);
  814. }
  815.  
  816. /*
  817.  *----------------------------------------------------------------------
  818.  *
  819.  * TimerHandlerSetupProc --
  820.  *
  821.  *    This procedure is part of the "event source" for timers.
  822.  *    It is invoked by Tcl_DoOneEvent before it calls select (or
  823.  *    whatever it uses to wait).
  824.  *
  825.  * Results:
  826.  *    None.
  827.  *
  828.  * Side effects:
  829.  *    Tells the notifier how long to sleep if it decides to block.
  830.  *
  831.  *----------------------------------------------------------------------
  832.  */
  833.  
  834. static void
  835. TimerHandlerSetupProc(clientData, flags)
  836.     ClientData clientData;        /* Not used. */
  837.     int flags;                /* Flags passed to Tk_DoOneEvent:
  838.                      * if it doesn't include
  839.                      * TCL_TIMER_EVENTS then we only
  840.                      * consider modal timers. */
  841. {
  842.     TimerHandler *timerHandlerPtr, *tPtr2;
  843.     Tcl_Time blockTime;
  844.  
  845.     /*
  846.      * Find the timer handler (regular or modal) that fires first.
  847.      */
  848.  
  849.     timerHandlerPtr = firstTimerHandlerPtr;
  850.     if (!(flags & TCL_TIMER_EVENTS)) {
  851.     timerHandlerPtr = NULL;
  852.     }
  853.     if (timerHandlerPtr != NULL) {
  854.     tPtr2 = firstModalHandlerPtr;
  855.     if (tPtr2 != NULL) {
  856.         if ((timerHandlerPtr->time.sec > tPtr2->time.sec)
  857.             || ((timerHandlerPtr->time.sec == tPtr2->time.sec)
  858.             && (timerHandlerPtr->time.usec > tPtr2->time.usec))) {
  859.         timerHandlerPtr = tPtr2;
  860.         }
  861.     }
  862.     } else {
  863.     timerHandlerPtr = firstModalHandlerPtr;
  864.     }
  865.     if (timerHandlerPtr == NULL) {
  866.     return;
  867.     }
  868.  
  869.     TclGetTime(&blockTime);
  870.     blockTime.sec = timerHandlerPtr->time.sec - blockTime.sec;
  871.     blockTime.usec = timerHandlerPtr->time.usec - blockTime.usec;
  872.     if (blockTime.usec < 0) {
  873.     blockTime.sec -= 1;
  874.     blockTime.usec += 1000000;
  875.     }
  876.     if (blockTime.sec < 0) {
  877.     blockTime.sec = 0;
  878.     blockTime.usec = 0;
  879.     }
  880.     Tcl_SetMaxBlockTime(&blockTime);
  881. }
  882.  
  883. /*
  884.  *----------------------------------------------------------------------
  885.  *
  886.  * TimerHandlerCheckProc --
  887.  *
  888.  *    This procedure is the second part of the "event source" for
  889.  *    file handlers.  It is invoked by Tcl_DoOneEvent after it calls
  890.  *    select (or whatever it uses to wait for events).
  891.  *
  892.  * Results:
  893.  *    None.
  894.  *
  895.  * Side effects:
  896.  *    Makes entries on the Tcl event queue for each file that is
  897.  *    now ready.
  898.  *
  899.  *----------------------------------------------------------------------
  900.  */
  901.  
  902. static void
  903. TimerHandlerCheckProc(clientData, flags)
  904.     ClientData clientData;        /* Not used. */
  905.     int flags;                /* Flags passed to Tk_DoOneEvent:
  906.                      * if it doesn't include 
  907.                      * TCL_TIMER_EVENTS then we only
  908.                      * consider modal timeouts. */
  909. {
  910.     TimerHandler *timerHandlerPtr;
  911.     TimerEvent *timerEvPtr;
  912.     int triggered, gotTime;
  913.     Tcl_Time curTime;
  914.  
  915.     triggered = 0;
  916.     gotTime = 0;
  917.     timerHandlerPtr = firstTimerHandlerPtr;
  918.     if ((flags & TCL_TIMER_EVENTS) && (timerHandlerPtr != NULL)) {
  919.     TclGetTime(&curTime);
  920.     gotTime = 1;
  921.     if ((timerHandlerPtr->time.sec < curTime.sec)
  922.         || ((timerHandlerPtr->time.sec == curTime.sec)
  923.         && (timerHandlerPtr->time.usec <= curTime.usec))) {
  924.         triggered = 1;
  925.     }
  926.     }
  927.     timerHandlerPtr = firstModalHandlerPtr;
  928.     if (timerHandlerPtr != NULL) {
  929.     if (!gotTime) {
  930.         TclGetTime(&curTime);
  931.     }
  932.     if ((timerHandlerPtr->time.sec < curTime.sec)
  933.         || ((timerHandlerPtr->time.sec == curTime.sec)
  934.         && (timerHandlerPtr->time.usec <= curTime.usec))) {
  935.         triggered = 1;
  936.     }
  937.     }
  938.     if (triggered) {
  939.     timerEvPtr = (TimerEvent *) ckalloc(sizeof(TimerEvent));
  940.     timerEvPtr->header.proc = TimerHandlerEventProc;
  941.     timerEvPtr->time.sec = curTime.sec;
  942.     timerEvPtr->time.usec = curTime.usec;
  943.     Tcl_QueueEvent((Tcl_Event *) timerEvPtr, TCL_QUEUE_TAIL);
  944.     }
  945. }
  946.  
  947. /*
  948.  *----------------------------------------------------------------------
  949.  *
  950.  * TimerHandlerExitProc --
  951.  *
  952.  *    Callback invoked during exit cleanup to destroy the timer event
  953.  *    source.
  954.  *
  955.  * Results:
  956.  *    None.
  957.  *
  958.  * Side effects:
  959.  *    Destroys the timer event source.
  960.  *
  961.  *----------------------------------------------------------------------
  962.  */
  963.  
  964.     /* ARGSUSED */
  965. static void
  966. TimerHandlerExitProc(clientData)
  967.     ClientData clientData;        /* Not used. */
  968. {
  969.     Tcl_DeleteEventSource(TimerHandlerSetupProc, TimerHandlerCheckProc,
  970.             (ClientData) NULL);
  971. }
  972.  
  973. /*
  974.  *----------------------------------------------------------------------
  975.  *
  976.  * TimerHandlerEventProc --
  977.  *
  978.  *    This procedure is called by Tcl_DoOneEvent when a timer event
  979.  *    reaches the front of the event queue.  This procedure handles
  980.  *    the event by invoking the callbacks for all timers that are
  981.  *    ready.
  982.  *
  983.  * Results:
  984.  *    Returns 1 if the event was handled, meaning it should be removed
  985.  *    from the queue.  Returns 0 if the event was not handled, meaning
  986.  *    it should stay on the queue.  The only time the event isn't
  987.  *    handled is if the TCL_TIMER_EVENTS flag bit isn't set.
  988.  *
  989.  * Side effects:
  990.  *    Whatever the timer handler callback procedures do.
  991.  *
  992.  *----------------------------------------------------------------------
  993.  */
  994.  
  995. static int
  996. TimerHandlerEventProc(evPtr, flags)
  997.     Tcl_Event *evPtr;        /* Event to service. */
  998.     int flags;            /* Flags that indicate what events to
  999.                  * handle, such as TCL_FILE_EVENTS. */
  1000. {
  1001.     TimerHandler *timerHandlerPtr;
  1002.     TimerEvent *timerEvPtr = (TimerEvent *) evPtr;
  1003.  
  1004.     /*
  1005.      * Invoke the current modal timeout first, if there is one and
  1006.      * it has triggered.
  1007.      */
  1008.  
  1009.     timerHandlerPtr = firstModalHandlerPtr;
  1010.     if (firstModalHandlerPtr != NULL) {
  1011.     if ((timerHandlerPtr->time.sec < timerEvPtr->time.sec)
  1012.         || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec)
  1013.         && (timerHandlerPtr->time.usec <= timerEvPtr->time.usec))) {
  1014.         (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
  1015.     }
  1016.     }
  1017.  
  1018.     /*
  1019.      * Invoke any normal timers that have fired.
  1020.      */
  1021.  
  1022.     if (!(flags & TCL_TIMER_EVENTS)) {
  1023.     return 1;
  1024.     }
  1025.  
  1026.     while (1) {
  1027.     timerHandlerPtr = firstTimerHandlerPtr;
  1028.     if (timerHandlerPtr == NULL) {
  1029.         break;
  1030.     }
  1031.     if ((timerHandlerPtr->time.sec > timerEvPtr->time.sec)
  1032.         || ((timerHandlerPtr->time.sec == timerEvPtr->time.sec)
  1033.         && (timerHandlerPtr->time.usec >= timerEvPtr->time.usec))) {
  1034.         break;
  1035.     }
  1036.  
  1037.     /*
  1038.      * Remove the handler from the queue before invoking it,
  1039.      * to avoid potential reentrancy problems.
  1040.      */
  1041.  
  1042.     firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
  1043.     (*timerHandlerPtr->proc)(timerHandlerPtr->clientData);
  1044.     ckfree((char *) timerHandlerPtr);
  1045.     }
  1046.     return 1;
  1047. }
  1048.  
  1049. /*
  1050.  *--------------------------------------------------------------
  1051.  *
  1052.  * Tcl_DoWhenIdle --
  1053.  *
  1054.  *    Arrange for proc to be invoked the next time the system is
  1055.  *    idle (i.e., just before the next time that Tcl_DoOneEvent
  1056.  *    would have to wait for something to happen).
  1057.  *
  1058.  * Results:
  1059.  *    None.
  1060.  *
  1061.  * Side effects:
  1062.  *    Proc will eventually be called, with clientData as argument.
  1063.  *    See the manual entry for details.
  1064.  *
  1065.  *--------------------------------------------------------------
  1066.  */
  1067.  
  1068. void
  1069. Tcl_DoWhenIdle(proc, clientData)
  1070.     Tcl_IdleProc *proc;        /* Procedure to invoke. */
  1071.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1072. {
  1073.     register IdleHandler *idlePtr;
  1074.  
  1075.     idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
  1076.     idlePtr->proc = proc;
  1077.     idlePtr->clientData = clientData;
  1078.     idlePtr->generation = idleGeneration;
  1079.     idlePtr->nextPtr = NULL;
  1080.     if (lastIdlePtr == NULL) {
  1081.     idleList = idlePtr;
  1082.     } else {
  1083.     lastIdlePtr->nextPtr = idlePtr;
  1084.     }
  1085.     lastIdlePtr = idlePtr;
  1086. }
  1087.  
  1088. /*
  1089.  *----------------------------------------------------------------------
  1090.  *
  1091.  * Tcl_CancelIdleCall --
  1092.  *
  1093.  *    If there are any when-idle calls requested to a given procedure
  1094.  *    with given clientData, cancel all of them.
  1095.  *
  1096.  * Results:
  1097.  *    None.
  1098.  *
  1099.  * Side effects:
  1100.  *    If the proc/clientData combination were on the when-idle list,
  1101.  *    they are removed so that they will never be called.
  1102.  *
  1103.  *----------------------------------------------------------------------
  1104.  */
  1105.  
  1106. void
  1107. Tcl_CancelIdleCall(proc, clientData)
  1108.     Tcl_IdleProc *proc;        /* Procedure that was previously registered. */
  1109.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1110. {
  1111.     register IdleHandler *idlePtr, *prevPtr;
  1112.     IdleHandler *nextPtr;
  1113.  
  1114.     for (prevPtr = NULL, idlePtr = idleList; idlePtr != NULL;
  1115.         prevPtr = idlePtr, idlePtr = idlePtr->nextPtr) {
  1116.     while ((idlePtr->proc == proc)
  1117.         && (idlePtr->clientData == clientData)) {
  1118.         nextPtr = idlePtr->nextPtr;
  1119.         ckfree((char *) idlePtr);
  1120.         idlePtr = nextPtr;
  1121.         if (prevPtr == NULL) {
  1122.         idleList = idlePtr;
  1123.         } else {
  1124.         prevPtr->nextPtr = idlePtr;
  1125.         }
  1126.         if (idlePtr == NULL) {
  1127.         lastIdlePtr = prevPtr;
  1128.         return;
  1129.         }
  1130.     }
  1131.     }
  1132. }
  1133.  
  1134. /*
  1135.  *----------------------------------------------------------------------
  1136.  *
  1137.  * TclIdlePending --
  1138.  *
  1139.  *    This function is called by the notifier subsystem to determine
  1140.  *    whether there are any idle handlers currently scheduled.
  1141.  *
  1142.  * Results:
  1143.  *    Returns 0 if the idle list is empty, otherwise it returns 1.
  1144.  *
  1145.  * Side effects:
  1146.  *    None.
  1147.  *
  1148.  *----------------------------------------------------------------------
  1149.  */
  1150.  
  1151. int
  1152. TclIdlePending()
  1153. {
  1154.     return (idleList == NULL) ? 0 : 1;
  1155. }
  1156.  
  1157. /*
  1158.  *----------------------------------------------------------------------
  1159.  *
  1160.  * TclServiceIdle --
  1161.  *
  1162.  *    This procedure is invoked by the notifier when it becomes idle.
  1163.  *
  1164.  * Results:
  1165.  *    The return value is 1 if the procedure actually found an idle
  1166.  *    handler to invoke.  If no handler was found then 0 is returned.
  1167.  *
  1168.  * Side effects:
  1169.  *    Invokes all pending idle handlers.
  1170.  *
  1171.  *----------------------------------------------------------------------
  1172.  */
  1173.  
  1174. int
  1175. TclServiceIdle()
  1176. {
  1177.     IdleHandler *idlePtr;
  1178.     int oldGeneration;
  1179.     int foundIdle;
  1180.  
  1181.     if (idleList == NULL) {
  1182.     return 0;
  1183.     }
  1184.     
  1185.     foundIdle = 0;
  1186.     oldGeneration = idleGeneration;
  1187.     idleGeneration++;
  1188.  
  1189.     /*
  1190.      * The code below is trickier than it may look, for the following
  1191.      * reasons:
  1192.      *
  1193.      * 1. New handlers can get added to the list while the current
  1194.      *    one is being processed.  If new ones get added, we don't
  1195.      *    want to process them during this pass through the list (want
  1196.      *    to check for other work to do first).  This is implemented
  1197.      *    using the generation number in the handler:  new handlers
  1198.      *    will have a different generation than any of the ones currently
  1199.      *    on the list.
  1200.      * 2. The handler can call Tcl_DoOneEvent, so we have to remove
  1201.      *    the handler from the list before calling it. Otherwise an
  1202.      *    infinite loop could result.
  1203.      * 3. Tcl_CancelIdleCall can be called to remove an element from
  1204.      *    the list while a handler is executing, so the list could
  1205.      *    change structure during the call.
  1206.      */
  1207.  
  1208.     for (idlePtr = idleList;
  1209.         ((idlePtr != NULL)
  1210.             && ((oldGeneration - idlePtr->generation) >= 0));
  1211.         idlePtr = idleList) {
  1212.     idleList = idlePtr->nextPtr;
  1213.     if (idleList == NULL) {
  1214.         lastIdlePtr = NULL;
  1215.     }
  1216.     foundIdle = 1;
  1217.     (*idlePtr->proc)(idlePtr->clientData);
  1218.     ckfree((char *) idlePtr);
  1219.     }
  1220.  
  1221.     return foundIdle;
  1222. }
  1223.  
  1224. /*
  1225.  *----------------------------------------------------------------------
  1226.  *
  1227.  * Tcl_BackgroundError --
  1228.  *
  1229.  *    This procedure is invoked to handle errors that occur in Tcl
  1230.  *    commands that are invoked in "background" (e.g. from event or
  1231.  *    timer bindings).
  1232.  *
  1233.  * Results:
  1234.  *    None.
  1235.  *
  1236.  * Side effects:
  1237.  *    The command "bgerror" is invoked later as an idle handler to
  1238.  *    process the error, passing it the error message.  If that fails,
  1239.  *    then an error message is output on stderr.
  1240.  *
  1241.  *----------------------------------------------------------------------
  1242.  */
  1243.  
  1244. void
  1245. Tcl_BackgroundError(interp)
  1246.     Tcl_Interp *interp;        /* Interpreter in which an error has
  1247.                  * occurred. */
  1248. {
  1249.     BgError *errPtr;
  1250.     char *varValue;
  1251.     ErrAssocData *assocPtr;
  1252.  
  1253.     /*
  1254.      * The Tcl_AddErrorInfo call below (with an empty string) ensures that
  1255.      * errorInfo gets properly set.  It's needed in cases where the error
  1256.      * came from a utility procedure like Tcl_GetVar instead of Tcl_Eval;
  1257.      * in these cases errorInfo still won't have been set when this
  1258.      * procedure is called.
  1259.      */
  1260.  
  1261.     Tcl_AddErrorInfo(interp, "");
  1262.     errPtr = (BgError *) ckalloc(sizeof(BgError));
  1263.     errPtr->interp = interp;
  1264.     errPtr->errorMsg = (char *) ckalloc((unsigned) (strlen(interp->result)
  1265.         + 1));
  1266.     strcpy(errPtr->errorMsg, interp->result);
  1267. #ifdef STk_CODE
  1268.     varValue = Tcl_GetVar(interp, "*error-info*", TCL_GLOBAL_ONLY);
  1269. #else
  1270.     varValue = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
  1271. #endif
  1272.     if (varValue == NULL) {
  1273.     varValue = errPtr->errorMsg;
  1274.     }
  1275.     errPtr->errorInfo = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
  1276.     strcpy(errPtr->errorInfo, varValue);
  1277. #ifdef STk_CODE
  1278.     varValue = Tcl_GetVar(interp, "*error-code*", TCL_GLOBAL_ONLY);
  1279. #else
  1280.     varValue = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
  1281. #endif
  1282.     if (varValue == NULL) {
  1283.     varValue = "";
  1284.     }
  1285.     errPtr->errorCode = (char *) ckalloc((unsigned) (strlen(varValue) + 1));
  1286.     strcpy(errPtr->errorCode, varValue);
  1287.     errPtr->nextPtr = NULL;
  1288.  
  1289.     assocPtr = (ErrAssocData *) Tcl_GetAssocData(interp, "tclBgError",
  1290.         (Tcl_InterpDeleteProc **) NULL);
  1291.     if (assocPtr == NULL) {
  1292.  
  1293.     /*
  1294.      * This is the first time a background error has occurred in
  1295.      * this interpreter.  Create associated data to keep track of
  1296.      * pending error reports.
  1297.      */
  1298.  
  1299.     assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
  1300.     assocPtr->firstBgPtr = NULL;
  1301.     assocPtr->lastBgPtr = NULL;
  1302.     Tcl_SetAssocData(interp, "tclBgError", BgErrorDeleteProc,
  1303.         (ClientData) assocPtr);
  1304.     }
  1305.     if (assocPtr->firstBgPtr == NULL) {
  1306.     assocPtr->firstBgPtr = errPtr;
  1307.     Tcl_DoWhenIdle(HandleBgErrors, (ClientData) assocPtr);
  1308.     } else {
  1309.     assocPtr->lastBgPtr->nextPtr = errPtr;
  1310.     }
  1311.     assocPtr->lastBgPtr = errPtr;
  1312.     Tcl_ResetResult(interp);
  1313. }
  1314.  
  1315. /*
  1316.  *----------------------------------------------------------------------
  1317.  *
  1318.  * HandleBgErrors --
  1319.  *
  1320.  *    This procedure is invoked as an idle handler to process all of
  1321.  *    the accumulated background errors.
  1322.  *
  1323.  * Results:
  1324.  *    None.
  1325.  *
  1326.  * Side effects:
  1327.  *    Depends on what actions "bgerror" takes for the errors.
  1328.  *
  1329.  *----------------------------------------------------------------------
  1330.  */
  1331.  
  1332. static void
  1333. HandleBgErrors(clientData)
  1334.     ClientData clientData;    /* Pointer to ErrAssocData structure. */
  1335. {
  1336.     Tcl_Interp *interp;
  1337.     char *command;
  1338.     char *argv[2];
  1339.     int code;
  1340.     BgError *errPtr;
  1341.     ErrAssocData *assocPtr = (ErrAssocData *) clientData;
  1342.     Tcl_Channel errChannel;
  1343.  
  1344.     while (assocPtr->firstBgPtr != NULL) {
  1345.     interp = assocPtr->firstBgPtr->interp;
  1346.     if (interp == NULL) {
  1347.         goto doneWithReport;
  1348.     }
  1349.  
  1350.     /*
  1351.      * Restore important state variables to what they were at
  1352.      * the time the error occurred.
  1353.      */
  1354.  
  1355. #ifdef STk_CODE
  1356.     Tcl_SetVar(interp, "*error-info*", assocPtr->firstBgPtr->errorInfo,
  1357.         STk_STRINGIFY | TCL_GLOBAL_ONLY);
  1358.     Tcl_SetVar(interp, "*error-code*", assocPtr->firstBgPtr->errorCode,
  1359.         STk_STRINGIFY | TCL_GLOBAL_ONLY);
  1360. #else
  1361.     Tcl_SetVar(interp, "errorInfo", assocPtr->firstBgPtr->errorInfo,
  1362.         TCL_GLOBAL_ONLY);
  1363.     Tcl_SetVar(interp, "errorCode", assocPtr->firstBgPtr->errorCode,
  1364.         TCL_GLOBAL_ONLY);
  1365. #endif
  1366.  
  1367.     /*
  1368.      * Create and invoke the bgerror command.
  1369.      */
  1370.  
  1371.     argv[0] = "bgerror";
  1372. #ifdef STk_CODE
  1373.     assocPtr->firstBgPtr->errorMsg= 
  1374.               (char *)STk_stringify(assocPtr->firstBgPtr->errorMsg, 1);
  1375. #endif
  1376.     argv[1] = assocPtr->firstBgPtr->errorMsg;
  1377.     command = Tcl_Merge(2, argv);
  1378.     Tcl_AllowExceptions(interp);
  1379.         Tcl_Preserve((ClientData) interp);
  1380.     code = Tcl_GlobalEval(interp, command);
  1381.     ckfree(command);
  1382.     if (code == TCL_ERROR) {
  1383.  
  1384.             /*
  1385.              * We have to get the error output channel at the latest possible
  1386.              * time, because the eval (above) might have changed the channel.
  1387.              */
  1388.             
  1389.             errChannel = Tcl_GetStdChannel(TCL_STDERR);
  1390.             if (errChannel != (Tcl_Channel) NULL) {
  1391.                 if (strcmp(interp->result,
  1392.            "\"bgerror\" is an invalid command name or ambiguous abbreviation")
  1393.                         == 0) {
  1394.                     Tcl_Write(errChannel, assocPtr->firstBgPtr->errorInfo, -1);
  1395.                     Tcl_Write(errChannel, "\n", -1);
  1396.                 } else {
  1397.                     Tcl_Write(errChannel,
  1398.                             "bgerror failed to handle background error.\n",
  1399.                             -1);
  1400.                     Tcl_Write(errChannel, "    Original error: ", -1);
  1401.                     Tcl_Write(errChannel, assocPtr->firstBgPtr->errorMsg,
  1402.                             -1);
  1403.                     Tcl_Write(errChannel, "\n", -1);
  1404.                     Tcl_Write(errChannel, "    Error in bgerror: ", -1);
  1405.                     Tcl_Write(errChannel, interp->result, -1);
  1406.                     Tcl_Write(errChannel, "\n", -1);
  1407.                 }
  1408.                 Tcl_Flush(errChannel);
  1409.             }
  1410.     } else if (code == TCL_BREAK) {
  1411.  
  1412.         /*
  1413.          * Break means cancel any remaining error reports for this
  1414.          * interpreter.
  1415.          */
  1416.  
  1417.         for (errPtr = assocPtr->firstBgPtr; errPtr != NULL;
  1418.             errPtr = errPtr->nextPtr) {
  1419.         if (errPtr->interp == interp) {
  1420.             errPtr->interp = NULL;
  1421.         }
  1422.         }
  1423.     }
  1424.  
  1425.         Tcl_Release((ClientData) interp);
  1426.  
  1427.     /*
  1428.      * Discard the command and the information about the error report.
  1429.      */
  1430.  
  1431.     doneWithReport:
  1432.     ckfree(assocPtr->firstBgPtr->errorMsg);
  1433.     ckfree(assocPtr->firstBgPtr->errorInfo);
  1434.     ckfree(assocPtr->firstBgPtr->errorCode);
  1435.     errPtr = assocPtr->firstBgPtr->nextPtr;
  1436.     ckfree((char *) assocPtr->firstBgPtr);
  1437.     assocPtr->firstBgPtr = errPtr;
  1438.     }
  1439.     assocPtr->lastBgPtr = NULL;
  1440. }
  1441.  
  1442. /*
  1443.  *----------------------------------------------------------------------
  1444.  *
  1445.  * BgErrorDeleteProc --
  1446.  *
  1447.  *    This procedure is associated with the "tclBgError" assoc data
  1448.  *    for an interpreter;  it is invoked when the interpreter is
  1449.  *    deleted in order to free the information assoicated with any
  1450.  *    pending error reports.
  1451.  *
  1452.  * Results:
  1453.  *    None.
  1454.  *
  1455.  * Side effects:
  1456.  *    Background error information is freed: if there were any
  1457.  *    pending error reports, they are cancelled.
  1458.  *
  1459.  *----------------------------------------------------------------------
  1460.  */
  1461.  
  1462. static void
  1463. BgErrorDeleteProc(clientData, interp)
  1464.     ClientData clientData;    /* Pointer to ErrAssocData structure. */
  1465.     Tcl_Interp *interp;        /* Interpreter being deleted. */
  1466. {
  1467.     ErrAssocData *assocPtr = (ErrAssocData *) clientData;
  1468.     BgError *errPtr;
  1469.  
  1470.     while (assocPtr->firstBgPtr != NULL) {
  1471.     errPtr = assocPtr->firstBgPtr;
  1472.     assocPtr->firstBgPtr = errPtr->nextPtr;
  1473.     ckfree(errPtr->errorMsg);
  1474.     ckfree(errPtr->errorInfo);
  1475.     ckfree(errPtr->errorCode);
  1476.     ckfree((char *) errPtr);
  1477.     }
  1478.     ckfree((char *) assocPtr);
  1479.     Tcl_CancelIdleCall(HandleBgErrors, (ClientData) assocPtr);
  1480. }
  1481.  
  1482. /*
  1483.  *----------------------------------------------------------------------
  1484.  *
  1485.  * Tcl_CreateExitHandler --
  1486.  *
  1487.  *    Arrange for a given procedure to be invoked just before the
  1488.  *    application exits.
  1489.  *
  1490.  * Results:
  1491.  *    None.
  1492.  *
  1493.  * Side effects:
  1494.  *    Proc will be invoked with clientData as argument when the
  1495.  *    application exits.
  1496.  *
  1497.  *----------------------------------------------------------------------
  1498.  */
  1499.  
  1500. void
  1501. Tcl_CreateExitHandler(proc, clientData)
  1502.     Tcl_ExitProc *proc;        /* Procedure to invoke. */
  1503.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1504. {
  1505.     ExitHandler *exitPtr;
  1506.  
  1507.     exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
  1508.     exitPtr->proc = proc;
  1509.     exitPtr->clientData = clientData;
  1510.     exitPtr->nextPtr = firstExitPtr;
  1511.     firstExitPtr = exitPtr;
  1512. }
  1513.  
  1514. /*
  1515.  *----------------------------------------------------------------------
  1516.  *
  1517.  * Tcl_DeleteExitHandler --
  1518.  *
  1519.  *    This procedure cancels an existing exit handler matching proc
  1520.  *    and clientData, if such a handler exits.
  1521.  *
  1522.  * Results:
  1523.  *    None.
  1524.  *
  1525.  * Side effects:
  1526.  *    If there is an exit handler corresponding to proc and clientData
  1527.  *    then it is cancelled;  if no such handler exists then nothing
  1528.  *    happens.
  1529.  *
  1530.  *----------------------------------------------------------------------
  1531.  */
  1532.  
  1533. void
  1534. Tcl_DeleteExitHandler(proc, clientData)
  1535.     Tcl_ExitProc *proc;        /* Procedure that was previously registered. */
  1536.     ClientData clientData;    /* Arbitrary value to pass to proc. */
  1537. {
  1538.     ExitHandler *exitPtr, *prevPtr;
  1539.  
  1540.     for (prevPtr = NULL, exitPtr = firstExitPtr; exitPtr != NULL;
  1541.         prevPtr = exitPtr, exitPtr = exitPtr->nextPtr) {
  1542.     if ((exitPtr->proc == proc)
  1543.         && (exitPtr->clientData == clientData)) {
  1544.         if (prevPtr == NULL) {
  1545.         firstExitPtr = exitPtr->nextPtr;
  1546.         } else {
  1547.         prevPtr->nextPtr = exitPtr->nextPtr;
  1548.         }
  1549.         ckfree((char *) exitPtr);
  1550.         return;
  1551.     }
  1552.     }
  1553. }
  1554.  
  1555. /*
  1556.  *----------------------------------------------------------------------
  1557.  *
  1558.  * Tcl_Exit --
  1559.  *
  1560.  *    This procedure is called to terminate the application.
  1561.  *
  1562.  * Results:
  1563.  *    None.
  1564.  *
  1565.  * Side effects:
  1566.  *    All existing exit handlers are invoked, then the application
  1567.  *    ends.
  1568.  *
  1569.  *----------------------------------------------------------------------
  1570.  */
  1571.  
  1572. void
  1573. Tcl_Exit(status)
  1574.     int status;            /* Exit status for application;  typically
  1575.                  * 0 for normal return, 1 for error return. */
  1576. {
  1577.     ExitHandler *exitPtr;
  1578.  
  1579.     for (exitPtr = firstExitPtr; exitPtr != NULL; exitPtr = firstExitPtr) {
  1580.     /*
  1581.      * Be careful to remove the handler from the list before invoking
  1582.      * its callback.  This protects us against double-freeing if the
  1583.      * callback should call Tcl_DeleteExitHandler on itself.
  1584.      */
  1585.  
  1586.     firstExitPtr = exitPtr->nextPtr;
  1587.     (*exitPtr->proc)(exitPtr->clientData);
  1588.     ckfree((char *) exitPtr);
  1589.     }
  1590. #ifdef TCL_MEM_DEBUG
  1591.     if (tclMemDumpFileName != NULL) {
  1592.     Tcl_DumpActiveMemory(tclMemDumpFileName);
  1593.     }
  1594. #endif
  1595.     
  1596.     TclPlatformExit(status);
  1597. }
  1598.  
  1599. /*
  1600.  *----------------------------------------------------------------------
  1601.  *
  1602.  * Tcl_AfterCmd --
  1603.  *
  1604.  *    This procedure is invoked to process the "after" Tcl command.
  1605.  *    See the user documentation for details on what it does.
  1606.  *
  1607.  * Results:
  1608.  *    A standard Tcl result.
  1609.  *
  1610.  * Side effects:
  1611.  *    See the user documentation.
  1612.  *
  1613.  *----------------------------------------------------------------------
  1614.  */
  1615.  
  1616.     /* ARGSUSED */
  1617. int
  1618. Tcl_AfterCmd(clientData, interp, argc, argv)
  1619.     ClientData clientData;    /* Points to the "tclAfter" assocData for
  1620.                  * this interpreter, or NULL if the assocData
  1621.                  * hasn't been created yet.*/
  1622.     Tcl_Interp *interp;        /* Current interpreter. */
  1623.     int argc;            /* Number of arguments. */
  1624.     char **argv;        /* Argument strings. */
  1625. {
  1626.     /*
  1627.      * The variable below is used to generate unique identifiers for
  1628.      * after commands.  This id can wrap around, which can potentially
  1629.      * cause problems.  However, there are not likely to be problems
  1630.      * in practice, because after commands can only be requested to
  1631.      * about a month in the future, and wrap-around is unlikely to
  1632.      * occur in less than about 1-10 years.  Thus it's unlikely that
  1633.      * any old ids will still be around when wrap-around occurs.
  1634.      */
  1635.  
  1636.     static int nextId = 1;
  1637.     int ms;
  1638.     AfterInfo *afterPtr;
  1639. #ifdef STk_CODE
  1640.     static int initialized = 0;
  1641.     void *closure;
  1642.     AfterAssocData *assocPtr = &After_list;
  1643. #else
  1644.     AfterAssocData *assocPtr = (AfterAssocData *) clientData;
  1645. #endif
  1646.     Tcl_CmdInfo cmdInfo;
  1647.     size_t length;
  1648.  
  1649.  
  1650.     if (argc < 2) {
  1651.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  1652.         argv[0], " option ?arg arg ...?\"", (char *) NULL);
  1653.     return TCL_ERROR;
  1654.     }
  1655.  
  1656. #ifdef STk_CODE
  1657.     if (!initialized) {
  1658.       After_list.interp = interp;     /* really useless !!!! */ 
  1659.       After_list.firstAfterPtr = NULL; 
  1660.       initialized = 1;
  1661.     }
  1662. #else
  1663.     /*
  1664.      * Create the "after" information associated for this interpreter,
  1665.      * if it doesn't already exist.  Associate it with the command too,
  1666.      * so that it will be passed in as the ClientData argument in the
  1667.      * future.
  1668.      */
  1669.  
  1670.     if (assocPtr == NULL) {
  1671.     assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
  1672.     assocPtr->interp = interp;
  1673.     assocPtr->firstAfterPtr = NULL;
  1674.     Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc,
  1675.         (ClientData) assocPtr);
  1676.     cmdInfo.proc = Tcl_AfterCmd;
  1677.     cmdInfo.clientData = (ClientData) assocPtr;
  1678.     cmdInfo.deleteProc = NULL;
  1679.     cmdInfo.deleteData = (ClientData) assocPtr;
  1680.     Tcl_SetCommandInfo(interp, argv[0], &cmdInfo);
  1681.     }
  1682. #endif
  1683.  
  1684.     /*
  1685.      * Parse the command.
  1686.      */
  1687.  
  1688.     length = strlen(argv[1]);
  1689.     if (isdigit(UCHAR(argv[1][0]))) {
  1690.     if (Tcl_GetInt(interp, argv[1], &ms) != TCL_OK) {
  1691.         return TCL_ERROR;
  1692.     }
  1693.     if (ms < 0) {
  1694.         ms = 0;
  1695.     }
  1696.     if (argc == 2) {
  1697.         Tcl_Sleep(ms);
  1698.         return TCL_OK;
  1699.     }
  1700.     afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
  1701.     afterPtr->assocPtr = assocPtr;
  1702.     if (argc == 3) {
  1703. #ifdef STk_CODE
  1704.         if (!STk_valid_callback(argv[2], &closure)) {
  1705.             Tcl_AppendResult(interp, "bad closure specification \"",
  1706.                          argv[2], "\"", (char *) NULL);
  1707.         return TCL_ERROR;
  1708.         }
  1709. #endif
  1710.         afterPtr->command = (char *) ckalloc((unsigned)
  1711.             (strlen(argv[2]) + 1));
  1712.         strcpy(afterPtr->command, argv[2]);
  1713.     } else {
  1714. #ifdef STk_CODE
  1715.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1716.             argv[0], " ms [script]\"", (char *) NULL);
  1717.         return TCL_ERROR;
  1718. #else
  1719.         afterPtr->command = Tcl_Concat(argc-2, argv+2);
  1720. #endif
  1721.     }
  1722.     afterPtr->id = nextId;
  1723.     nextId += 1;
  1724.     afterPtr->token = Tcl_CreateTimerHandler(ms, AfterProc,
  1725.         (ClientData) afterPtr);
  1726.     afterPtr->nextPtr = assocPtr->firstAfterPtr;
  1727.     assocPtr->firstAfterPtr = afterPtr;
  1728.     sprintf(interp->result, "after#%d", afterPtr->id);
  1729. #ifdef STk_CODE
  1730.     if (closure != NULL)
  1731.       /* Register the callback to prinevent it to be GC'ed */
  1732.       STk_add_callback(interp->result, "", "", closure);
  1733. #endif
  1734.     } else if (strncmp(argv[1], "cancel", length) == 0) {
  1735.     char *arg;
  1736.  
  1737.     if (argc < 3) {
  1738.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1739.             argv[0], " cancel id|command\"", (char *) NULL);
  1740.         return TCL_ERROR;
  1741.     }
  1742.     if (argc == 3) {
  1743.         arg = argv[2];
  1744. #ifndef STk_CODE
  1745.     } else {
  1746.         arg = Tcl_Concat(argc-2, argv+2);
  1747. #endif
  1748.     }
  1749.     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
  1750.         afterPtr = afterPtr->nextPtr) {
  1751.         if (strcmp(afterPtr->command, arg) == 0) {
  1752.         break;
  1753.         }
  1754.     }
  1755.     if (afterPtr == NULL) {
  1756.         afterPtr = GetAfterEvent(assocPtr, arg);
  1757.     }
  1758. #ifndef STk_CODE
  1759.     if (arg != argv[2]) {
  1760.         ckfree(arg);
  1761.     }
  1762. #endif
  1763.     if (afterPtr != NULL) {
  1764.         if (afterPtr->token != NULL) {
  1765.         Tcl_DeleteTimerHandler(afterPtr->token);
  1766.         } else {
  1767.         Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
  1768.         }
  1769.         FreeAfterPtr(afterPtr);
  1770.     }
  1771.     } else if ((strncmp(argv[1], "idle", length) == 0)
  1772.          && (length >= 2)) {
  1773. #ifdef STk_CODE
  1774.     if (argc != 3) {
  1775.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1776.             argv[0], " idle script\"", (char *) NULL);
  1777.         return TCL_ERROR;
  1778.     }
  1779.     if (!STk_valid_callback(argv[2], &closure)) {
  1780.       Tcl_AppendResult(interp, "bad closure specification \"",
  1781.                argv[2], "\"", (char *) NULL);
  1782.       return TCL_ERROR;
  1783.     }
  1784. #else
  1785.     if (argc < 3) {
  1786.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1787.             argv[0], " idle script script ...\"", (char *) NULL);
  1788.         return TCL_ERROR;
  1789.     }
  1790. #endif
  1791.     afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
  1792.     afterPtr->assocPtr = assocPtr;
  1793. #ifdef STk_CODE
  1794.     afterPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
  1795.     strcpy(afterPtr->command, argv[2]);
  1796. #else
  1797.     if (argc == 3) {
  1798.         afterPtr->command = (char *) ckalloc((unsigned)
  1799.             (strlen(argv[2]) + 1));
  1800.         strcpy(afterPtr->command, argv[2]);
  1801.     } else {
  1802.         afterPtr->command = Tcl_Concat(argc-2, argv+2);
  1803.     }
  1804. #endif
  1805.     afterPtr->id = nextId;
  1806.     nextId += 1;
  1807.     afterPtr->token = NULL;
  1808.     afterPtr->nextPtr = assocPtr->firstAfterPtr;
  1809.     assocPtr->firstAfterPtr = afterPtr;
  1810.     Tcl_DoWhenIdle(AfterProc, (ClientData) afterPtr);
  1811.     sprintf(interp->result, "after#%d", afterPtr->id);
  1812. #ifdef STk_CODE
  1813.     if (closure != NULL)
  1814.       /* Register the callback to prevent it to be GC'ed */
  1815.       STk_add_callback(interp->result, "", "", closure);
  1816. #endif
  1817.     } else if ((strncmp(argv[1], "info", length) == 0)
  1818.          && (length >= 2)) {
  1819.     if (argc == 2) {
  1820.         char buffer[30];
  1821.  
  1822. #ifdef STk_CODE
  1823.         Tcl_AppendResult(interp, "(", NULL);
  1824. #endif
  1825.         for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
  1826.             afterPtr = afterPtr->nextPtr) {
  1827.         if (assocPtr->interp == interp) {
  1828.             sprintf(buffer, "after#%d", afterPtr->id);
  1829.             Tcl_AppendElement(interp, buffer);
  1830.         }
  1831.         }
  1832. #ifdef STk_CODE
  1833.         Tcl_AppendResult(interp, ")", NULL);
  1834. #endif
  1835.         return TCL_OK;
  1836.     }
  1837.     if (argc != 3) {
  1838.         Tcl_AppendResult(interp, "wrong # args: should be \"",
  1839.             argv[0], " info ?id?\"", (char *) NULL);
  1840.         return TCL_ERROR;
  1841.     }
  1842.     afterPtr = GetAfterEvent(assocPtr, argv[2]);
  1843.     if (afterPtr == NULL) {
  1844.         Tcl_AppendResult(interp, "event \"", argv[2],
  1845.             "\" doesn't exist", (char *) NULL);
  1846.         return TCL_ERROR;
  1847.     }
  1848.     Tcl_AppendElement(interp, afterPtr->command);
  1849.     Tcl_AppendElement(interp,
  1850.         (afterPtr->token == NULL) ? "idle" : "timer");
  1851.     } else {
  1852.     Tcl_AppendResult(interp, "bad argument \"", argv[1],
  1853.         "\": must be cancel, idle, info, or a number",
  1854.         (char *) NULL);
  1855.     return TCL_ERROR;
  1856.     }
  1857.     return TCL_OK;
  1858. }
  1859.  
  1860. /*
  1861.  *----------------------------------------------------------------------
  1862.  *
  1863.  * GetAfterEvent --
  1864.  *
  1865.  *    This procedure parses an "after" id such as "after#4" and
  1866.  *    returns a pointer to the AfterInfo structure.
  1867.  *
  1868.  * Results:
  1869.  *    The return value is either a pointer to an AfterInfo structure,
  1870.  *    if one is found that corresponds to "string" and is for interp,
  1871.  *    or NULL if no corresponding after event can be found.
  1872.  *
  1873.  * Side effects:
  1874.  *    None.
  1875.  *
  1876.  *----------------------------------------------------------------------
  1877.  */
  1878.  
  1879. static AfterInfo *
  1880. GetAfterEvent(assocPtr, string)
  1881.     AfterAssocData *assocPtr;    /* Points to "after"-related information for
  1882.                  * this interpreter. */
  1883.     char *string;        /* Textual identifier for after event, such
  1884.                  * as "after#6". */
  1885. {
  1886.     AfterInfo *afterPtr;
  1887.     int id;
  1888.     char *end;
  1889.  
  1890.     if (strncmp(string, "after#", 6) != 0) {
  1891.     return NULL;
  1892.     }
  1893.     string += 6;
  1894.     id = strtoul(string, &end, 10);
  1895.     if ((end == string) || (*end != 0)) {
  1896.     return NULL;
  1897.     }
  1898.     for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
  1899.         afterPtr = afterPtr->nextPtr) {
  1900.     if (afterPtr->id == id) {
  1901.         return afterPtr;
  1902.     }
  1903.     }
  1904.     return NULL;
  1905. }
  1906.  
  1907. /*
  1908.  *----------------------------------------------------------------------
  1909.  *
  1910.  * AfterProc --
  1911.  *
  1912.  *    Timer callback to execute commands registered with the
  1913.  *    "after" command.
  1914.  *
  1915.  * Results:
  1916.  *    None.
  1917.  *
  1918.  * Side effects:
  1919.  *    Executes whatever command was specified.  If the command
  1920.  *    returns an error, then the command "bgerror" is invoked
  1921.  *    to process the error;  if bgerror fails then information
  1922.  *    about the error is output on stderr.
  1923.  *
  1924.  *----------------------------------------------------------------------
  1925.  */
  1926.  
  1927. static void
  1928. AfterProc(clientData)
  1929.     ClientData clientData;    /* Describes command to execute. */
  1930. {
  1931.     AfterInfo *afterPtr = (AfterInfo *) clientData;
  1932.     AfterAssocData *assocPtr = afterPtr->assocPtr;
  1933.     AfterInfo *prevPtr;
  1934.     int result;
  1935.     Tcl_Interp *interp;
  1936.  
  1937.     /*
  1938.      * First remove the callback from our list of callbacks;  otherwise
  1939.      * someone could delete the callback while it's being executed, which
  1940.      * could cause a core dump.
  1941.      */
  1942.  
  1943.     if (assocPtr->firstAfterPtr == afterPtr) {
  1944.     assocPtr->firstAfterPtr = afterPtr->nextPtr;
  1945.     } else {
  1946.     for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
  1947.         prevPtr = prevPtr->nextPtr) {
  1948.         /* Empty loop body. */
  1949.     }
  1950.     prevPtr->nextPtr = afterPtr->nextPtr;
  1951.     }
  1952.  
  1953.     /*
  1954.      * Execute the callback.
  1955.      */
  1956.  
  1957.     interp = assocPtr->interp;
  1958.     Tcl_Preserve((ClientData) interp);
  1959.     result = Tcl_GlobalEval(interp, afterPtr->command);
  1960.     if (result != TCL_OK) {
  1961.     Tcl_AddErrorInfo(interp, "\n    (\"after\" script)");
  1962.     Tcl_BackgroundError(interp);
  1963.     }
  1964.     Tcl_Release((ClientData) interp);
  1965.     
  1966.     /*
  1967.      * Free the memory for the callback.
  1968.      */
  1969.  
  1970.     ckfree(afterPtr->command);
  1971.     ckfree((char *) afterPtr);
  1972. }
  1973.  
  1974. /*
  1975.  *----------------------------------------------------------------------
  1976.  *
  1977.  * FreeAfterPtr --
  1978.  *
  1979.  *    This procedure removes an "after" command from the list of
  1980.  *    those that are pending and frees its resources.  This procedure
  1981.  *    does *not* cancel the timer handler;  if that's needed, the
  1982.  *    caller must do it.
  1983.  *
  1984.  * Results:
  1985.  *    None.
  1986.  *
  1987.  * Side effects:
  1988.  *    The memory associated with afterPtr is released.
  1989.  *
  1990.  *----------------------------------------------------------------------
  1991.  */
  1992.  
  1993. static void
  1994. FreeAfterPtr(afterPtr)
  1995.     AfterInfo *afterPtr;        /* Command to be deleted. */
  1996. {
  1997.     AfterInfo *prevPtr;
  1998.     AfterAssocData *assocPtr = afterPtr->assocPtr;
  1999.  
  2000.     if (assocPtr->firstAfterPtr == afterPtr) {
  2001.     assocPtr->firstAfterPtr = afterPtr->nextPtr;
  2002.     } else {
  2003.     for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
  2004.         prevPtr = prevPtr->nextPtr) {
  2005.         /* Empty loop body. */
  2006.     }
  2007.     prevPtr->nextPtr = afterPtr->nextPtr;
  2008.     }
  2009.     ckfree(afterPtr->command);
  2010.     ckfree((char *) afterPtr);
  2011. }
  2012.  
  2013. #ifndef STk_CODE
  2014. /*
  2015.  *----------------------------------------------------------------------
  2016.  *
  2017.  * AfterCleanupProc --
  2018.  *
  2019.  *    This procedure is invoked whenever an interpreter is deleted
  2020.  *    to cleanup the AssocData for "tclAfter".
  2021.  *
  2022.  * Results:
  2023.  *    None.
  2024.  *
  2025.  * Side effects:
  2026.  *    After commands are removed.
  2027.  *
  2028.  *----------------------------------------------------------------------
  2029.  */
  2030.  
  2031.     /* ARGSUSED */
  2032. static void
  2033. AfterCleanupProc(clientData, interp)
  2034.     ClientData clientData;    /* Points to AfterAssocData for the
  2035.                  * interpreter. */
  2036.     Tcl_Interp *interp;        /* Interpreter that is being deleted. */
  2037. {
  2038.     AfterAssocData *assocPtr = (AfterAssocData *) clientData;
  2039.     AfterInfo *afterPtr;
  2040.  
  2041.     while (assocPtr->firstAfterPtr != NULL) {
  2042.     afterPtr = assocPtr->firstAfterPtr;
  2043.     assocPtr->firstAfterPtr = afterPtr->nextPtr;
  2044.     if (afterPtr->token != NULL) {
  2045.         Tcl_DeleteTimerHandler(afterPtr->token);
  2046.     } else {
  2047.         Tcl_CancelIdleCall(AfterProc, (ClientData) afterPtr);
  2048.     }
  2049.     ckfree(afterPtr->command);
  2050.     ckfree((char *) afterPtr);
  2051.     }
  2052.     ckfree((char *) assocPtr);
  2053. }
  2054.  
  2055. /*
  2056.  *----------------------------------------------------------------------
  2057.  *
  2058.  * Tcl_VwaitCmd --
  2059.  *
  2060.  *    This procedure is invoked to process the "vwait" Tcl command.
  2061.  *    See the user documentation for details on what it does.
  2062.  *
  2063.  * Results:
  2064.  *    A standard Tcl result.
  2065.  *
  2066.  * Side effects:
  2067.  *    See the user documentation.
  2068.  *
  2069.  *----------------------------------------------------------------------
  2070.  */
  2071.  
  2072.     /* ARGSUSED */
  2073. int
  2074. Tcl_VwaitCmd(clientData, interp, argc, argv)
  2075.     ClientData clientData;    /* Not used. */
  2076.     Tcl_Interp *interp;        /* Current interpreter. */
  2077.     int argc;            /* Number of arguments. */
  2078.     char **argv;        /* Argument strings. */
  2079. {
  2080.     int done, foundEvent;
  2081.  
  2082.     if (argc != 2) {
  2083.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  2084.         argv[0], " name\"", (char *) NULL);
  2085.     return TCL_ERROR;
  2086.     }
  2087.     Tcl_TraceVar(interp, argv[1],
  2088.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  2089.         VwaitVarProc, (ClientData) &done);
  2090.     done = 0;
  2091.     foundEvent = 1;
  2092.     while (!done && foundEvent) {
  2093.     foundEvent = Tcl_DoOneEvent(0);
  2094.     }
  2095.     Tcl_UntraceVar(interp, argv[1],
  2096.         TCL_GLOBAL_ONLY|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
  2097.         VwaitVarProc, (ClientData) &done);
  2098.  
  2099.     /*
  2100.      * Clear out the interpreter's result, since it may have been set
  2101.      * by event handlers.
  2102.      */
  2103.  
  2104.     Tcl_ResetResult(interp);
  2105.     if (!foundEvent) {
  2106.     Tcl_AppendResult(interp, "can't wait for variable \"", argv[1],
  2107.         "\":  would wait forever", (char *) NULL);
  2108.     return TCL_ERROR;
  2109.     }
  2110.     return TCL_OK;
  2111. }
  2112.  
  2113.     /* ARGSUSED */
  2114. static char *
  2115. VwaitVarProc(clientData, interp, name1, name2, flags)
  2116.     ClientData clientData;    /* Pointer to integer to set to 1. */
  2117.     Tcl_Interp *interp;        /* Interpreter containing variable. */
  2118.     char *name1;        /* Name of variable. */
  2119.     char *name2;        /* Second part of variable name. */
  2120.     int flags;            /* Information about what happened. */
  2121. {
  2122.     int *donePtr = (int *) clientData;
  2123.  
  2124.     *donePtr = 1;
  2125.     return (char *) NULL;
  2126. }
  2127. #endif
  2128.  
  2129. /*
  2130.  *----------------------------------------------------------------------
  2131.  *
  2132.  * Tcl_UpdateCmd --
  2133.  *
  2134.  *    This procedure is invoked to process the "update" Tcl command.
  2135.  *    See the user documentation for details on what it does.
  2136.  *
  2137.  * Results:
  2138.  *    A standard Tcl result.
  2139.  *
  2140.  * Side effects:
  2141.  *    See the user documentation.
  2142.  *
  2143.  *----------------------------------------------------------------------
  2144.  */
  2145.  
  2146.     /* ARGSUSED */
  2147. int
  2148. Tcl_UpdateCmd(clientData, interp, argc, argv)
  2149.     ClientData clientData;    /* Not used. */
  2150.     Tcl_Interp *interp;        /* Current interpreter. */
  2151.     int argc;            /* Number of arguments. */
  2152.     char **argv;        /* Argument strings. */
  2153. {
  2154.     int flags = 0;        /* Initialization needed only to stop
  2155.                  * compiler warnings. */
  2156.  
  2157.     if (argc == 1) {
  2158.     flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
  2159.     } else if (argc == 2) {
  2160.     if (strncmp(argv[1], "idletasks", strlen(argv[1])) != 0) {
  2161.         Tcl_AppendResult(interp, "bad option \"", argv[1],
  2162.             "\": must be idletasks", (char *) NULL);
  2163.         return TCL_ERROR;
  2164.     }
  2165.     flags = TCL_IDLE_EVENTS|TCL_DONT_WAIT;
  2166.     } else {
  2167.     Tcl_AppendResult(interp, "wrong # args: should be \"",
  2168.         argv[0], " ?idletasks?\"", (char *) NULL);
  2169.     return TCL_ERROR;
  2170.     }
  2171.  
  2172.     while (Tcl_DoOneEvent(flags) != 0) {
  2173.     /* Empty loop body */
  2174.     }
  2175.  
  2176.     /*
  2177.      * Must clear the interpreter's result because event handlers could
  2178.      * have executed commands.
  2179.      */
  2180.  
  2181.     Tcl_ResetResult(interp);
  2182.     return TCL_OK;
  2183. }
  2184.  
  2185. #ifndef STk_CODE
  2186. /*
  2187.  *----------------------------------------------------------------------
  2188.  *
  2189.  * TclWaitForFile --
  2190.  *
  2191.  *    This procedure waits synchronously for a file to become readable
  2192.  *    or writable, with an optional timeout.
  2193.  *
  2194.  * Results:
  2195.  *    The return value is an OR'ed combination of TCL_READABLE,
  2196.  *    TCL_WRITABLE, and TCL_EXCEPTION, indicating the conditions
  2197.  *    that are present on file at the time of the return.  This
  2198.  *    procedure will not return until either "timeout" milliseconds
  2199.  *    have elapsed or at least one of the conditions given by mask
  2200.  *    has occurred for file (a return value of 0 means that a timeout
  2201.  *    occurred).  No normal events will be serviced during the
  2202.  *    execution of this procedure.
  2203.  *
  2204.  * Side effects:
  2205.  *    Time passes.
  2206.  *
  2207.  *----------------------------------------------------------------------
  2208.  */
  2209.  
  2210. int
  2211. TclWaitForFile(file, mask, timeout)
  2212.     Tcl_File file;        /* Handle for file on which to wait. */
  2213.     int mask;            /* What to wait for: OR'ed combination of
  2214.                  * TCL_READABLE, TCL_WRITABLE, and
  2215.                  * TCL_EXCEPTION. */
  2216.     int timeout;        /* Maximum amount of time to wait for one
  2217.                  * of the conditions in mask to occur, in
  2218.                  * milliseconds.  A value of 0 means don't
  2219.                  * wait at all, and a value of -1 means
  2220.                  * wait forever. */
  2221. {
  2222.     Tcl_Time abortTime, now, blockTime;
  2223.     int present;
  2224.  
  2225.     /*
  2226.      * If there is a non-zero finite timeout, compute the time when
  2227.      * we give up.
  2228.      */
  2229.  
  2230.     if (timeout > 0) {
  2231.     TclGetTime(&now);
  2232.     abortTime.sec = now.sec + timeout/1000;
  2233.     abortTime.usec = now.usec + (timeout%1000)*1000;
  2234.     if (abortTime.usec >= 1000000) {
  2235.         abortTime.usec -= 1000000;
  2236.         abortTime.sec += 1;
  2237.     }
  2238.     }
  2239.  
  2240.     /*
  2241.      * Loop in a mini-event loop of our own, waiting for either the
  2242.      * file to become ready or a timeout to occur.
  2243.      */
  2244.  
  2245.     while (1) {
  2246.     Tcl_WatchFile(file, mask);
  2247.     if (timeout > 0) {
  2248.         blockTime.sec = abortTime.sec - now.sec;
  2249.         blockTime.usec = abortTime.usec - now.usec;
  2250.         if (blockTime.usec < 0) {
  2251.         blockTime.sec -= 1;
  2252.         blockTime.usec += 1000000;
  2253.         }
  2254.         if (blockTime.sec < 0) {
  2255.         blockTime.sec = 0;
  2256.         blockTime.usec = 0;
  2257.         }
  2258.         Tcl_WaitForEvent(&blockTime);
  2259.     } else if (timeout == 0) {
  2260.         blockTime.sec = 0;
  2261.         blockTime.usec = 0;
  2262.         Tcl_WaitForEvent(&blockTime);
  2263.     } else {
  2264.         Tcl_WaitForEvent((Tcl_Time *) NULL);
  2265.     }
  2266.     present = Tcl_FileReady(file, mask);
  2267.     if (present != 0) {
  2268.         break;
  2269.     }
  2270.     if (timeout == 0) {
  2271.         break;
  2272.     }
  2273.     TclGetTime(&now);
  2274.     if ((abortTime.sec < now.sec)
  2275.         || ((abortTime.sec == now.sec)
  2276.         && (abortTime.usec <= now.usec))) {
  2277.         break;
  2278.     }
  2279.     }
  2280.     return present;
  2281. }
  2282. #endif
  2283.